home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / NEWSOFT / AUGUST / WORKDISC / !Forthmacs / lib / debug < prev    next >
Text File  |  1997-04-18  |  6KB  |  184 lines
  1. \ < Copyright 1985-1990 Bradley Forthware
  2.  
  3. \ Debugger.  Thanks, Mike Perry, Henry Laxen, Mark Smeder.
  4. \
  5. \ The debugger lets you single step the execution of a high level
  6. \ definition.  To invoke the debugger, type debug xxx where xxx is
  7. \ the name of the word you wish to trace.  When xxx executes, you will
  8. \ get a single step trace showing you the word within xxx that
  9. \ is about to execute, and the contents of the parameter stack.
  10. \ Debugging makes everything run slightly slower, even outside
  11. \ the word being debugged.  see debug-off
  12. \
  13. \ debug name    Mark that word for debugging
  14. \ stepping    Debug in single step mode
  15. \ tracing    Debug in trace mode
  16. \ debug-off    Turn off the debugger (makes the system run fast again)
  17. \ resume    Exit from a pushed interpreter (see the f keystroke)
  18. \
  19. \ Keystroke commands while you're single-stepping
  20. \   d        go down a level
  21. \   u        go up a level
  22. \   c        continue trace without single stepping
  23. \   g        go  turn off stepping and continue execution
  24. \   f        push a Forth interpreter,  execute "resume" to get back
  25. \ > q        abort back to the top level
  26.  
  27. hex
  28. only forth also definitions  system also  hidden also
  29. bug also definitions
  30.  
  31. \needs slow-next ??cr .( Warning- a cpu specific debugger module must be loaded first) abort
  32. needs interact lib/interact.fth
  33.  
  34. variable slow-next?  slow-next? off
  35. variable step? step? on
  36. variable res
  37. : (debug)    (s low-adr hi-adr -- )
  38.     unbug
  39.     1 cnt !   ip> !   <ip !   pnext
  40.     slow-next? @ 0=
  41.     if    here  low-dictionary-adr  slow-next
  42.         slow-next? on
  43.     then
  44.     step? on ;
  45. : 'unnest    (s pfa -- pfa' )
  46.     begin dup cell+ swap token@ ['] unnest =  until ;
  47. : set-<ip    (s pfa -- )
  48.     <ip !
  49.     <ip @  ip> @  u>=
  50.     if <ip @  'unnest  ip> !  then ;
  51.  
  52. false value first-time?
  53. \ Enter and leave the debugger
  54. forth definitions
  55.  
  56. : defer?    ( acf -- flag )    word-type  ['] key word-type =  ;
  57. : colon-cf?    ( acf -- flag )    word-type  ['] defer? word-type = ;
  58. : (debug    ( acf -- )
  59.     begin dup defer? while behavior repeat
  60.     dup colon-cf? 0= abort" Not a colon definition"
  61.     >body dup 'unnest (debug)
  62.     true is first-time? ;
  63. \ Debug the caller
  64. : debug-me    (s -- )    ip@ find-cfa (debug  ;
  65. : debug(    (s -- )    ip@ dup 'unnest (debug)  ;
  66. : )debug    (s -- )    ip@ ip> !  ;
  67. : debug-off    (s -- )    unbug  here low-dictionary-adr fast-next slow-next? off ;
  68.  
  69. bug also definitions
  70. \ Go up the return stack until we find the return address left by our caller
  71. : caller-ip    ( rp -- ip )
  72.     begin    cell+ dup @  dup  in-dictionary?
  73.     if    ( rs-adr ip )
  74.         ip>token token@
  75.         dup ['] execute =  over defer? or  swap <ip @ body> =  or
  76.     else    drop false
  77.     then
  78.     until                                     ( rs-adr )
  79.     @ ip>token ;
  80. : up1    ( rp -- )
  81.     caller-ip
  82.     dup find-cfa   ( ip cfa )
  83.     cr ." [ Up to " dup .name ." ]" cr  ( ip cfa )
  84.     over token@ .name                   ( ip cfa )
  85.     >body swap 'unnest (debug) ;
  86.  
  87. defer to-debug-window    ' noop is to-debug-window
  88. defer restore-window    ' noop is restore-window
  89.  
  90. : .debug-short-help    ( -- )
  91.     ." Stepper keys: <space> Down Up Continue Forth Go Help ? See $tring " [char] " emit ." string Quit" cr ;
  92. : .debug-long-help    ( -- )
  93.     ." Key     Action" cr
  94.     ." <space> Execute displayed word" cr
  95.     ." D       Down: Step down into displayed word" cr
  96.     ." U       Up: Finish current definition and step in its caller" cr
  97.     ." C       Continue: trace current definition without stopping" cr
  98.     ." F       Forth: enter a subordinate Forth interpreter" cr
  99.     ." G       Go: resume normal execution (stop debugging)" cr
  100.     ." H       Help: display this message" cr
  101.     ." ?       Display short list of debug commands" cr
  102.     ." R       RSTrace: Show contents of Forth return stack" cr
  103.     ." S       See: Decompile definition being debugged" cr
  104.     ." $       Display top of stack as adr,len text string" cr
  105.     [char] " emit
  106.      ."        Display top of stack as counted string" cr
  107.     ." Q       Quit: abandon execution of the debugged word" cr ;
  108.  
  109. d# 24 constant cmd-column
  110. 0 value rp-mark
  111. : to-cmd-column    ( -- )    cmd-column to-column  ;
  112.  
  113. \ set-package is a hook for Open Firmware.  When Open Firmware is loaded,
  114. \ set-package should be set to a word that sets the active package to the
  115. \ package corresponding to the current instance.  set-package is called
  116. \ by the "F" key, so the user will see the methods of the current instance.
  117. defer set-package    ' noop is   set-package
  118. defer unset-package    ' noop is unset-package
  119.  
  120. : try        ( n acf -- okay? )
  121.     catch ?dup if .error drop false else true then ;
  122. : (trace  ( -- )
  123.     first-time?
  124.     if    ??cr ip@  <ip @ =
  125.         if  ." : "  else  ." Inside "  then
  126.         <ip @ find-cfa .name
  127.         false is first-time?
  128.         rp@ is rp-mark
  129.     then
  130.     begin    step? @  if to-debug-window then
  131.         cmd-column 2+ to-column  ." ( " .s ." )" cr   \ Show stack
  132.         ['] noop is indent
  133.         ip@ .token  drop          \ Show word name
  134.         ['] (indent) is indent
  135.         to-cmd-column
  136.         step? @ key? or
  137.         if    step? on  res off
  138.             key dup bl < if drop bl then dup emit upc
  139.             restore-window
  140.             reset-page
  141.             case
  142.             [char] D of ip@ token@  dup ['] execute  =  if  drop dup  then
  143.                 ['] (debug try                    endof \ Down
  144.             [char] U of rp@ ['] up1 try                endof \ Up
  145.             [char] C of step? @ 0= step? ! true            endof \ Continue
  146.             [char] F of cr ." Type 'resume' to return to debugger" cr
  147.                 set-package interact unset-package false    endof                           \ Forth
  148.             [char] G of debug-off  cr  exit                endof \ Go
  149.             [char] H of cr .debug-long-help    false            endof \ Help
  150.             [char] R of cr rp0 @ rp@ cell+ (rstrace false        endof \ RSTrace
  151.             [char] S of cr <ip @ body> (see) false            endof \ See
  152.             [char] ? of cr .debug-short-help false            endof \ Short Help
  153.             [char] " of space dup ". cr    to-cmd-column false    endof \ counted string
  154.             [char] $ of space 2dup type cr to-cmd-column false    endof \ String
  155.             [char] Q of cr ." unbug" abort           true        endof \ Quit
  156.             [char] ( of ip@ set-<ip                  false        endof
  157.             [char] < of ip@ cell+ set-<ip 1 cnt !    false        endof
  158.             [char] ) of ip@ ip> !  1 cnt !           false        endof
  159.             [char] * of ip@ find-cfa dup <ip ! 'unnest ip> ! false    endof
  160.             ( default )  true swap
  161.             endcase
  162.         else    true
  163.         then
  164.     until
  165.     ip@ token@  dup ['] unnest =  swap ['] exit =  or
  166.     if cr  true is first-time? then
  167.     pnext ;
  168. ' (trace  'debug token!
  169.  
  170. only forth bug also forth definitions
  171.  
  172. : debug  \ name (s -- )
  173.    '
  174.    .debug-short-help
  175.    (debug
  176. ;
  177. : debugging  ( -- )  ' .debug-short-help  dup (debug  execute  ;
  178. : resume    (s -- )  true is exit-interact?  pnext  ;
  179. : stepping  (s -- )  step? on  ;
  180. : tracing   (s -- )  step? off ;
  181.  
  182. : (bye    unbug debug-off (bye ; ' (bye is bye
  183. only forth also definitions  decimal
  184.